home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / read.d < prev    next >
Encoding:
Text File  |  1994-05-07  |  56.6 KB  |  2,673 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19. */
  20.  
  21. /*
  22.     read.d
  23. */
  24.  
  25. #include "include.h"
  26. #include "mp.h"
  27.  
  28. #define    token_buffer    token->st.st_self
  29.  
  30.  
  31. object dispatch_reader;
  32.  
  33.  
  34. #define    cat(c)    (READtable->rt.rt_self[char_code((c))] \
  35.          .rte_chattrib)
  36.  
  37. #ifndef SHARP_EQ_CONTEXT_SIZE
  38. #define    SHARP_EQ_CONTEXT_SIZE    250
  39. #endif
  40.  
  41. setup_READtable()
  42. {
  43.     READtable = current_readtable();
  44. }
  45.  
  46. struct sharp_eq_context_struct {
  47.     object    sharp_index;
  48.     object    sharp_eq;
  49.     object    sharp_sharp;
  50. } sharp_eq_context[SHARP_EQ_CONTEXT_SIZE];
  51.  
  52. /*
  53.     NOTE:
  54.  
  55.         I believe that there is no need to enter
  56.         sharp_eq_context to mark_origin.
  57. */
  58.  
  59.  
  60. setup_READ()
  61. {
  62.     object x;
  63.  
  64.     READtable = current_readtable();
  65.     x = symbol_value(Vread_default_float_format);
  66.     if (x == Sshort_float)
  67.         READdefault_float_format = 'S';
  68.     else if (x == Ssingle_float || x == Sdouble_float || x == Slong_float)
  69.         READdefault_float_format = 'F';
  70.     else {
  71.         vs_push(x);
  72.         Vread_default_float_format->s.s_dbind = Ssingle_float;
  73.     FEerror("The value of *READ-DEFAULT-FLOAT-FORMAT*, ~S, was illegal.",
  74.             1, x);
  75.     }
  76.     x = symbol_value(Vread_base);
  77.     if (type_of(x) != t_fixnum || fix(x) < 2 || fix(x) > 36) {
  78.         vs_push(x);
  79.         Vread_base->s.s_dbind = make_fixnum(10);
  80.         FEerror("The value of *READ-BASE*, ~S, was illegal.", 1, x);
  81.     }
  82.     READbase = fix(x);
  83.     READsuppress = symbol_value(Vread_suppress) != Cnil;
  84.     sharp_eq_context_max = 0;
  85.  
  86.     backq_level = 0;
  87. }
  88.  
  89. setup_standard_READ()
  90. {
  91.     READtable = standard_readtable;
  92.     READdefault_float_format = 'F';
  93.     READbase = 10;
  94.     READsuppress = FALSE;
  95.     sharp_eq_context_max = 0;
  96.     backq_level = 0;
  97. }
  98.  
  99. object
  100. read_char(in)
  101. object in;
  102. {
  103.     return(code_char(readc_stream(in)));
  104. }
  105.  
  106. #define    read_char(in)    code_char(readc_stream(in))
  107.  
  108. unread_char(c, in)
  109. object c, in;
  110. {
  111.     if (type_of(c) != t_character)
  112.         FEwrong_type_argument(Scharacter, c);
  113.     unreadc_stream(char_code(c), in);
  114. }
  115.  
  116. /*
  117.     Peek_char corresponds to COMMON Lisp function PEEK-CHAR.
  118.     When pt is TRUE, preceeding whitespaces are ignored.
  119. */
  120. object
  121. peek_char(pt, in)
  122. bool pt;
  123. object in;
  124. {
  125.     object c;
  126.  
  127.     if (pt) {
  128.         do
  129.             c = read_char(in);
  130.         while (cat(c) == cat_whitespace);
  131.         unread_char(c, in);
  132.         return(c);
  133.     } else {
  134.         c = read_char(in);
  135.         unread_char(c, in);
  136.         return(c);
  137.     }
  138. }
  139.         
  140.  
  141. object
  142. read_object_recursive(in)
  143. object in;
  144. {
  145.     VOL object x;
  146.     bool e;
  147.  
  148.     object old_READtable = READtable;
  149.     int old_READdefault_float_format = READdefault_float_format;
  150.     int old_READbase = READbase;
  151.     bool old_READsuppress = READsuppress;
  152.  
  153.     /* BUG FIX by Toshiba */
  154.     vs_push(old_READtable);
  155.  
  156.     frs_push(FRS_PROTECT, Cnil);
  157.     if (nlj_active) {
  158.         e = TRUE;
  159.         goto L;
  160.     }
  161.  
  162.     READtable = current_readtable();
  163.     x = symbol_value(Vread_default_float_format);
  164.     if (x == Sshort_float)
  165.         READdefault_float_format = 'S';
  166.     else if (x == Ssingle_float || x == Sdouble_float || x == Slong_float)
  167.         READdefault_float_format = 'F';
  168.     else {
  169.         vs_push(x);
  170.         Vread_default_float_format->s.s_dbind = Ssingle_float;
  171.     FEerror("The value of *READ-DEFAULT-FLOAT-FORMAT*, ~S, was illegal.",
  172.             1, x);
  173.     }
  174.     x = symbol_value(Vread_base);
  175.     if (type_of(x) != t_fixnum || fix(x) < 2 || fix(x) > 36) {
  176.         vs_push(x);
  177.         Vread_base->s.s_dbind = make_fixnum(10);
  178.         FEerror("The value of *READ-BASE*, ~S, was illegal.", 1, x);
  179.     }
  180.     READbase = fix(x);
  181.     READsuppress = symbol_value(Vread_suppress) != Cnil;
  182.  
  183.     x = read_object(in);
  184.     e = FALSE;
  185.  
  186. L:
  187.     frs_pop();
  188.  
  189.     READtable = old_READtable;
  190.     READdefault_float_format = old_READdefault_float_format;
  191.     READbase = old_READbase;
  192.     READsuppress = old_READsuppress;
  193.  
  194.     /* BUG FIX by Toshiba */
  195.     vs_pop;
  196.  
  197.     if (e) {
  198.         nlj_active = FALSE;
  199.         unwind(nlj_fr, nlj_tag);
  200.     }
  201.  
  202.     return(x);
  203. }
  204.  
  205.  
  206. object
  207. read_object_non_recursive(in)
  208. object in;
  209. {
  210.     VOL object x;
  211.     int i;
  212.     bool e;
  213.     object old_READtable;
  214.     int old_READdefault_float_format;
  215.     int old_READbase;
  216.     int old_READsuppress;
  217.     int old_sharp_eq_context_max;
  218.     struct sharp_eq_context_struct
  219.         old_sharp_eq_context[SHARP_EQ_CONTEXT_SIZE];
  220.     int old_backq_level;
  221.  
  222.     old_READtable = READtable;
  223.     old_READdefault_float_format = READdefault_float_format;
  224.     old_READbase = READbase;
  225.     old_READsuppress = READsuppress;
  226.     old_sharp_eq_context_max = sharp_eq_context_max;
  227.     /* BUG FIX by Toshiba */
  228.     vs_push(old_READtable);
  229.     for (i = 0;  i < sharp_eq_context_max;  i++)
  230.         old_sharp_eq_context[i] = sharp_eq_context[i];
  231.     old_backq_level = backq_level;
  232.     setup_READ();
  233.  
  234.     frs_push(FRS_PROTECT, Cnil);
  235.     if (nlj_active) {
  236.         e = TRUE;
  237.         goto L;
  238.     }
  239.  
  240.     x = read_object(in);
  241.     vs_push(x);
  242.  
  243.     if (sharp_eq_context_max > 0)
  244.         x = vs_head = patch_sharp(x);
  245.  
  246.     e = FALSE;
  247.  
  248. L:
  249.     frs_pop();
  250.  
  251.     READtable = old_READtable;
  252.     READdefault_float_format = old_READdefault_float_format;
  253.     READbase = old_READbase;
  254.     READsuppress = old_READsuppress;
  255.     sharp_eq_context_max = old_sharp_eq_context_max;
  256.     for (i = 0;  i < sharp_eq_context_max;  i++)
  257.         sharp_eq_context[i] = old_sharp_eq_context[i];
  258.     backq_level = old_backq_level;
  259.     if (e) {
  260.         nlj_active = FALSE;
  261.         unwind(nlj_fr, nlj_tag);
  262.     }
  263.     vs_pop;
  264.     /* BUG FIX by Toshiba */
  265.     vs_pop;
  266.     return(x);
  267. }
  268.  
  269. object
  270. standard_read_object_non_recursive(in)
  271. object in;
  272. {
  273.     VOL object x;
  274.     int i;
  275.     bool e;
  276.     object old_READtable;
  277.     int old_READdefault_float_format;
  278.     int old_READbase;
  279.     int old_READsuppress;
  280.     int old_sharp_eq_context_max;
  281.     struct sharp_eq_context_struct
  282.         old_sharp_eq_context[SHARP_EQ_CONTEXT_SIZE];
  283.     int old_backq_level;
  284.  
  285.     old_READtable = READtable;
  286.     old_READdefault_float_format = READdefault_float_format;
  287.     old_READbase = READbase;
  288.     old_READsuppress = READsuppress;
  289.     old_sharp_eq_context_max = sharp_eq_context_max;
  290.     /* BUG FIX by Toshiba */
  291.     vs_push(old_READtable);
  292.     for (i = 0;  i < sharp_eq_context_max;  i++)
  293.         old_sharp_eq_context[i] = sharp_eq_context[i];
  294.     old_backq_level = backq_level;
  295.  
  296.     setup_standard_READ();
  297.  
  298.     frs_push(FRS_PROTECT, Cnil);
  299.     if (nlj_active) {
  300.         e = TRUE;
  301.         goto L;
  302.     }
  303.  
  304.     x = read_object(in);
  305.     vs_push(x);
  306.  
  307.     if (sharp_eq_context_max > 0)
  308.         x = vs_head = patch_sharp(x);
  309.  
  310.     e = FALSE;
  311.  
  312. L:
  313.     frs_pop();
  314.  
  315.     READtable = old_READtable;
  316.     READdefault_float_format = old_READdefault_float_format;
  317.     READbase = old_READbase;
  318.     READsuppress = old_READsuppress;
  319.     sharp_eq_context_max = old_sharp_eq_context_max;
  320.     for (i = 0;  i < sharp_eq_context_max;  i++)
  321.         sharp_eq_context[i] = old_sharp_eq_context[i];
  322.     backq_level = old_backq_level;
  323.     if (e) {
  324.         nlj_active = FALSE;
  325.         unwind(nlj_fr, nlj_tag);
  326.     }
  327.     vs_pop;
  328.     /* BUG FIX by Toshiba */
  329.     vs_pop;
  330.     return(x);
  331. }
  332. #ifdef UNIX  /* faster code for inner loop from file stream */
  333. #define read_char_to(res,in,eof_code) \
  334.   do{FILE *fp; \
  335.       if(fp=in->sm.sm_fp) \
  336.     {int ch = getc(fp); \
  337.        if(ch==EOF && feof(fp)) \
  338.          {eof_code;} \
  339.        else res=code_char(ch);} \
  340.       else \
  341.     { if (stream_at_end(in)) \
  342.         {eof_code;} \
  343.     else res=read_char(in);}} while(0)
  344. #else
  345. #define read_char_to(res,in,eof_code) \
  346.   if(stream_at_end(in)) {eof_code ;} \
  347.   else res=read_char(in)
  348. #endif
  349.  
  350. /*
  351.     Read_object(in) reads an object from stream in.
  352.     This routine corresponds to COMMON Lisp function READ.
  353. */
  354. object
  355. read_object(in)
  356. object in;
  357. {
  358.     object x;
  359.     object c;
  360.     enum chattrib a;
  361.     object *old_vs_base;
  362.     object result;
  363.     object p;
  364.     int length, colon, colon_type;
  365.     int i, d;
  366.     bool df, ilf;
  367.     vs_mark;
  368.  
  369.     cs_check(in);
  370.  
  371.     vs_check_push(delimiting_char);
  372.     delimiting_char = OBJNULL;
  373.     df = detect_eos_flag;
  374.     detect_eos_flag = FALSE;
  375.     ilf = in_list_flag;
  376.     in_list_flag = FALSE;
  377.     dot_flag = FALSE;
  378.  
  379. BEGIN:
  380.     do { read_char_to(c,in, {
  381.       if (df) {
  382.         vs_reset;
  383.         return(OBJNULL);
  384.       } else
  385.         end_of_stream(in);
  386.     });
  387.         a = cat(c);
  388.     } while (a == cat_whitespace);
  389.     delimiting_char = vs_head;
  390.     if (delimiting_char != OBJNULL && c == delimiting_char) {
  391.         delimiting_char = OBJNULL;
  392.         vs_reset;
  393.         return(OBJNULL);
  394.     }
  395.     delimiting_char = OBJNULL;
  396.     if (a == cat_terminating || a == cat_non_terminating)
  397.     {
  398.         object *fun_box = vs_top;
  399.  
  400.         old_vs_base = vs_base;
  401.         vs_push(Cnil);
  402.         vs_base = vs_top;
  403.         vs_push(in);
  404.         vs_push(c);
  405.  
  406.         x =
  407.         READtable->rt.rt_self[char_code(c)].rte_macro;
  408.         fun_box[0] = x;
  409.         super_funcall(x);
  410.  
  411.         i = vs_top - vs_base;
  412.         if (i == 0) {
  413.             vs_base = old_vs_base;
  414.             vs_top = old_vs_top + 1;
  415.             goto BEGIN;
  416.         }
  417.         if (i > 1) {
  418.             vs_push(make_fixnum(i));
  419.             FEerror("The readmacro ~S returned ~D values.",
  420.                  2, fun_box[0], vs_top[-1]);
  421.         }
  422.         result = vs_base[0];
  423.         vs_base = old_vs_base;
  424.         vs_reset;
  425.         return(result);
  426.     }
  427.     escape_flag = FALSE;
  428.     length = 0;
  429.     colon_type = 0;
  430.     goto L;
  431.     for (;;) {
  432.         if (length >= token->st.st_dim)
  433.             too_long_token();
  434.         token_buffer[length++] = char_code(c);
  435.     K:
  436.         read_char_to(c,in,goto M);
  437.         a = cat(c);
  438.     L:
  439.         if (a == cat_single_escape) {
  440.             c = read_char(in);
  441.             a = cat_constituent;
  442.             escape_flag = TRUE;
  443.         } else if (a == cat_multiple_escape) {
  444.             escape_flag = TRUE;
  445.             for (;;) {
  446.                 if (stream_at_end(in))
  447.                     end_of_stream(in);
  448.                 c = read_char(in);
  449.                 a = cat(c);
  450.                 if (a == cat_single_escape) {
  451.                     c = read_char(in);
  452.                     a = cat_constituent;
  453.                 } else if (a == cat_multiple_escape)
  454.                     break;
  455.                 if (length >= token->st.st_dim)
  456.                     too_long_token();
  457.                 token_buffer[length++] = char_code(c);
  458.             }
  459.             goto K;
  460.         } else if (a == cat_whitespace || a == cat_terminating)
  461.             break;
  462.         else if ('a' <= char_code(c) && char_code(c) <= 'z')
  463.             c = code_char(char_code(c) - ('a' - 'A'));
  464.         else if (char_code(c) == ':') {
  465.             if (colon_type == 0) {
  466.                 colon_type = 1;
  467.                 colon = length;
  468.             } else if (colon_type == 1 && colon == length-1)
  469.                 colon_type = 2;
  470.             else
  471.                 colon_type = -1;
  472.                 /*  Colon has appeared twice.  */
  473.         }
  474.         }
  475.     if (preserving_whitespace_flag || cat(c) != cat_whitespace)
  476.         unread_char(c, in);
  477.  
  478. M:
  479.     if (READsuppress) {
  480.         token->st.st_fillp = length;
  481.         vs_reset;
  482.         return(Cnil);
  483.     }
  484.     if (ilf && !escape_flag &&
  485.         length == 1 && token->st.st_self[0] == '.') {
  486.         dot_flag = TRUE;
  487.         vs_reset;
  488.         return(Cnil);
  489.     } else if (!escape_flag && length > 0) {
  490.         for (i = 0;  i < length;  i++)
  491.             if (token->st.st_self[i] != '.')
  492.                 goto N;
  493.         FEerror("Dots appeared illegally.", 0);
  494.     }
  495.  
  496. N:
  497.     token->st.st_fillp = length;
  498.     if (escape_flag || (READbase<=10 && token_buffer[0]>'9'))
  499.         goto SYMBOL;
  500.     x = parse_number(token_buffer, length, &i, READbase);
  501.     if (x != OBJNULL && length == i) {
  502.         vs_reset;
  503.         return(x);
  504.     }
  505.  
  506. SYMBOL:
  507.     if (colon_type == 1 /* && length > colon + 1 */) {
  508.         if (colon == 0)
  509.             p = keyword_package;
  510.         else {
  511.             token->st.st_fillp = colon;
  512.             p = find_package(token);
  513.             if (p == Cnil) {
  514.                 vs_push(copy_simple_string(token));
  515.                 FEerror("There is no package with the name ~A.",
  516.                     1, vs_head);
  517.             }
  518.         }
  519.         for (i = colon + 1;  i < length;  i++)
  520.             token_buffer[i - (colon + 1)]
  521.             = token_buffer[i];
  522.         token->st.st_fillp = length - (colon + 1);
  523.         if (colon > 0) {
  524.             x = find_symbol(token, p);
  525.             if (intern_flag != EXTERNAL) {
  526.                 vs_push(copy_simple_string(token));
  527.             FEerror("Cannot find the external symbol ~A in ~S.",
  528.                         2, vs_head, p);
  529.                 /*  no need to push a package  */
  530.             }
  531.             vs_reset;
  532.             return(x);
  533.         }
  534.     } else if (colon_type == 2 /* && colon > 0 && length > colon + 2 */) {
  535.         token->st.st_fillp = colon;
  536.         p = find_package(token);
  537.         if (p == Cnil) {
  538.             vs_push(copy_simple_string(token));
  539.             FEerror("There is no package with the name ~A.",
  540.                 1, vs_head);
  541.         }
  542.         for (i = colon + 2;  i < length;  i++)
  543.             token_buffer[i - (colon + 2)]
  544.             = token_buffer[i];
  545.         token->st.st_fillp = length - (colon + 2);
  546.     } else
  547.         p = current_package();
  548.     vs_push(p);
  549.     x = intern(token, p);
  550.     vs_push(x);
  551.     if (x->s.s_self == token_buffer) {
  552.         x->s.s_self = alloc_relblock(token->st.st_fillp);
  553.         for (i = 0;  i < token->st.st_fillp;  i++)
  554.             x->s.s_self[i] = token_buffer[i];
  555.     }
  556.     vs_reset;
  557.     return(x);
  558. }
  559.  
  560. Lleft_parenthesis_reader()
  561. {
  562.     object in, c, x;
  563.     object *p;
  564.  
  565.     check_arg(2);
  566.     in = vs_base[0];
  567.     vs_head = Cnil;
  568.     p = &vs_head;
  569.     for (;;) {
  570.         delimiting_char = code_char(')');
  571.         in_list_flag = TRUE;
  572.         x = read_object(in);
  573.         if (x == OBJNULL)
  574.             goto ENDUP;
  575.         if (dot_flag) {
  576.             if (p == &vs_head)
  577.     FEerror("A dot appeared after a left parenthesis.", 0);
  578.             in_list_flag = TRUE;
  579.             *p = read_object(in);
  580.             if (dot_flag)
  581.     FEerror("Two dots appeared consecutively.", 0);
  582.             c = read_char(in);
  583.             while (cat(c) == cat_whitespace)
  584.                 c = read_char(in);
  585.             if (char_code(c) != ')')
  586.     FEerror("A dot appeared before a right parenthesis.", 0);
  587.             goto ENDUP;
  588.         }
  589.         vs_push(x);
  590.         *p = make_cons(x, Cnil);
  591.         vs_pop;
  592.         p = &((*p)->c.c_cdr);
  593.     }
  594.  
  595. ENDUP:
  596.     vs_base[0] = vs_pop;
  597.     return;
  598. }
  599.  
  600. #define    is_exponent_marker(i)    \
  601.     ((i) == 'e' || (i) == 'E' ||    \
  602.      (i) == 's' || (i) == 'S' || (i) == 'f' || (i) == 'F' || \
  603.      (i) == 'd' || (i) == 'D' || (i) == 'l' || (i) == 'L' || \
  604.      (i) == 'b' || (i) == 'B')
  605.  
  606. double pow();
  607. /*
  608.     Parse_number(s, end, ep, radix) parses C string s
  609.     up to (but not including) s[end]
  610.     using radix as the radix for the rational number.
  611.     (For floating numbers, radix should be 10.)
  612.     When parsing has been succeeded,
  613.     the index of the next character is assigned to *ep,
  614.     and the number is returned as a lisp data object.
  615.     If not, OBJNULL is returned.
  616. */
  617. object
  618. parse_number(s, end, ep, radix)
  619. char *s;
  620. int end, *ep, radix;
  621. {
  622.     object x, r;
  623.     fixnum sign;
  624.     object integer_part;
  625.     double fraction, fraction_unit, f;
  626.     char exponent_marker;
  627.     int exponent;
  628.     int i, j, k;
  629.     int d;
  630.     vs_mark;
  631.  
  632.     if (s[end-1] == '.')
  633.         radix = 10;
  634.         /*
  635.             DIRTY CODE!!
  636.         */
  637. BEGIN:
  638.     exponent_marker = 'E';
  639.     i = 0;
  640.     sign = 1;
  641.     if (s[i] == '+')
  642.         i++;
  643.     else if (s[i] == '-') {
  644.         sign = -1;
  645.         i++;
  646.     }
  647.     integer_part = (object)  big_register_0;
  648.     ZERO_BIG(big_register_0);
  649.     vs_push((object)integer_part);
  650.     if (i >= end)
  651.         goto NO_NUMBER;
  652.     if (s[i] == '.') {
  653.         if (radix != 10) {
  654.             radix = 10;
  655.             goto BEGIN;
  656.         }
  657.         i++;
  658.         goto FRACTION;
  659.     }
  660.     if ((d = digitp(s[i], radix)) < 0)
  661.         goto NO_NUMBER;
  662.     do {
  663.         mul_int_big(radix, integer_part);
  664.         add_int_big(d, integer_part);
  665.         i++;
  666.     } while (i < end && (d = digitp(s[i], radix)) >= 0);
  667.     if (i >= end)
  668.         goto MAKE_INTEGER;
  669.     if (s[i] == '.') {
  670.         if (radix != 10) {
  671.             radix = 10;
  672.             goto BEGIN;
  673.         }
  674.         if (++i >= end)
  675.             goto MAKE_INTEGER;
  676.         else if (digitp(s[i], radix) >= 0)
  677.             goto FRACTION;
  678.         else if (is_exponent_marker(s[i])) {
  679.             fraction
  680.             = (double)sign * big_to_double(integer_part);
  681.             goto EXPONENT;
  682.         } else
  683.             goto MAKE_INTEGER;
  684.     }
  685.     if (s[i] == '/') {
  686.         i++;
  687.         goto DENOMINATOR;
  688.     }
  689.     if (is_exponent_marker(s[i])) {
  690.         fraction = (double)sign * big_to_double(integer_part);
  691.         goto EXPONENT;
  692.     }
  693. /*
  694.     goto NO_NUMBER;
  695. */
  696.  
  697. MAKE_INTEGER:
  698.     if (sign < 0 && signe(MP(integer_part)))
  699.         set_big_sign(integer_part,-1);
  700.     x = normalize_big_to_object(integer_part);
  701. /**/
  702.     if (x == big_register_0)
  703.         big_register_0 = alloc_object(t_bignum);
  704.     ZERO_BIG(big_register_0);
  705.  
  706. /**/
  707.     goto END;
  708.  
  709. FRACTION:
  710. /*
  711.     if (radix != 10)
  712.         goto NO_NUMBER;
  713. */
  714.     radix = 10;
  715.     if ((d = digitp(s[i], radix)) < 0)
  716.         goto NO_NUMBER;
  717.     fraction = 0.0;
  718.     fraction_unit = 1000000000.0;
  719.     for (;;) {
  720.         k = j = 0;
  721.         do {
  722.             j = 10*j + d;
  723.             i++;
  724.             k++;
  725.             if (i < end)
  726.                 d = digitp(s[i], radix);
  727.             else
  728.                 break;
  729.         } while (k < 9 && d >= 0);
  730.         while (k++ < 9)
  731.             j *= 10;
  732.         fraction += ((double)j /fraction_unit);
  733.         if (i >= end || d < 0)
  734.             break;
  735.         fraction_unit *= 1000000000.0;
  736.     }
  737.     fraction += big_to_double(integer_part);
  738.     fraction *= (double)sign;
  739.     if (i >= end)
  740.         goto MAKE_FLOAT;
  741.     if (is_exponent_marker(s[i]))
  742.         goto EXPONENT;
  743.     goto MAKE_FLOAT;
  744.  
  745. EXPONENT:
  746. /*
  747.     if (radix != 10)
  748.         goto NO_NUMBER;
  749. */
  750.     radix = 10;
  751.     exponent_marker = s[i];
  752.     i++;
  753.     if (i >= end)
  754.         goto NO_NUMBER;
  755.     sign = 1;
  756.     if (s[i] == '+')
  757.         i++;
  758.     else if (s[i] == '-') {
  759.         sign = -1;
  760.         i++;
  761.     }
  762.     if (i >= end)
  763.         goto NO_NUMBER;
  764.     if ((d = digitp(s[i], radix)) < 0)
  765.         goto NO_NUMBER;
  766.     exponent = 0;
  767.     do {
  768.         exponent = 10 * exponent + d;
  769.         i++;
  770.     } while (i < end && (d = digitp(s[i], radix)) >= 0);
  771.     d = exponent;
  772.     f = 10.0;
  773.     /* Use pow because it is more accurate */
  774.     { double po = pow(10.0,(double)(sign * d));
  775.           if (po == 0.0)
  776.             { fraction = fraction *pow(10.0,(double)(sign * (d-1)));
  777.                fraction /= 10.0;}  
  778.           else     
  779.         fraction = fraction * po;}
  780.  
  781. MAKE_FLOAT:
  782. #ifdef IEEEFLOAT
  783.     if ((*((int *)&fraction +HIND) & 0x7ff00000) == 0x7ff00000)
  784.         FEerror("Floating-point overflow.", 0);
  785. #endif
  786.     switch (exponent_marker) {
  787.  
  788.     case 'e':  case 'E':
  789.         exponent_marker = READdefault_float_format;
  790.         goto MAKE_FLOAT;
  791.  
  792.     case 's':  case 'S':
  793.         x = make_shortfloat((shortfloat)fraction);
  794.         break;
  795.  
  796.     case 'f':  case 'F':  case 'd':  case 'D':  case 'l':  case 'L':
  797.         x = make_longfloat((longfloat)fraction);
  798.         break;
  799.  
  800.     case 'b':  case 'B':
  801.         goto NO_NUMBER;
  802.     }
  803. /**/
  804.     ZERO_BIG(big_register_0);
  805.  
  806.  
  807. /**/
  808.     goto END;
  809.  
  810. DENOMINATOR:
  811.     if (sign < 0)
  812.         set_big_sign(integer_part,-1);
  813.     vs_push(normalize_big_to_object(integer_part));
  814. /**/
  815.     if (vs_head == big_register_0)
  816.         big_register_0 = alloc_object(t_bignum);
  817.     ZERO_BIG(big_register_0);
  818.  
  819. /**/
  820.     if ((d = digitp(s[i], radix)) < 0)
  821.         goto NO_NUMBER;
  822.     integer_part = alloc_object(t_bignum);
  823.     ZERO_BIG(integer_part);
  824.     do {
  825.         mul_int_big(radix, integer_part);
  826.         add_int_big(d, integer_part);
  827.         i++;
  828.     } while (i < end && (d = digitp(s[i], radix)) >= 0);
  829.     vs_push(normalize_big_to_object(integer_part));
  830.     x = make_ratio(vs_top[-2], vs_top[-1]);
  831.     goto END;
  832.  
  833. END:
  834.     *ep = i;
  835.     vs_reset;
  836.     return(x);
  837.  
  838. NO_NUMBER:
  839.     *ep = i;
  840.     vs_reset;
  841. /**/
  842.     ZERO_BIG(big_register_0);
  843.  
  844.  
  845.  /**/
  846.     return(OBJNULL);
  847. }
  848.  
  849. object
  850. parse_integer(s, end, ep, radix)
  851. char *s;
  852. int end, *ep, radix;
  853. {
  854.     object x, r;
  855.     fixnum sign;
  856.     object integer_part;
  857.     int i, d;
  858.     vs_mark;
  859.  
  860.     i = 0;
  861.     sign = 1;
  862.     if (s[i] == '+')
  863.         i++;
  864.     else if (s[i] == '-') {
  865.         sign = -1;
  866.         i++;
  867.     }
  868.     integer_part = big_register_0;
  869.     vs_push((object)integer_part);
  870.     if (i >= end)
  871.         goto NO_NUMBER;
  872.     if ((d = digitp(s[i], radix)) < 0)
  873.         goto NO_NUMBER;
  874.     do {
  875.         mul_int_big(radix, integer_part);
  876.         add_int_big(d, integer_part);
  877.         i++;
  878.     } while (i < end && (d = digitp(s[i], radix)) >= 0);
  879.     if (sign < 0)
  880.         set_big_sign(integer_part,-1);
  881.     x = normalize_big_to_object(integer_part);
  882. /**/
  883.     if (x == big_register_0)
  884.         big_register_0 = alloc_object(t_bignum);
  885.     ZERO_BIG(big_register_0);
  886.     
  887. /**/
  888.     *ep = i;
  889.     vs_reset;
  890.     return(x);
  891.  
  892. NO_NUMBER:
  893.     *ep = i;
  894.     vs_reset;
  895. /**/
  896.     ZERO_BIG(big_register_0);
  897. /**/
  898.     return(OBJNULL);
  899. }
  900. /*
  901.     Read_string(delim, in) reads
  902.     a simple string    terminated by character code delim
  903.     and places it in token.
  904.     Delim is not included in the string but discarded.
  905. */
  906. read_string(delim, in)
  907. int delim;
  908. object in;
  909. {
  910.     int i;
  911.     object c;
  912.  
  913.     i = 0;
  914.     for (;;) {
  915.         c = read_char(in);
  916.         if (char_code(c) == delim)
  917.             break;
  918.         else if (cat(c) == cat_single_escape)
  919.             c = read_char(in);
  920.         if (i >= token->st.st_dim)
  921.             too_long_string();
  922.         token_buffer[i++] = char_code(c);
  923.     }
  924.     token->st.st_fillp = i;
  925. }
  926.  
  927. /*
  928.     Read_constituent(in) reads
  929.     a sequence of constituent characters from stream in
  930.     and places it in token_buffer.
  931. */
  932. read_constituent(in)
  933. object in;
  934. {
  935.     int i, j;
  936.     object c;
  937.  
  938.     i = 0;
  939.     for (;;) {
  940.                 read_char_to(c,in,goto FIN);
  941.         if (cat(c) != cat_constituent) {
  942.             unread_char(c, in);
  943.             break;
  944.         }
  945.         j = char_code(c);
  946.         token_buffer[i++] = j;
  947.     }
  948.       FIN:
  949.     token->st.st_fillp = i;
  950.     
  951. }
  952.  
  953. Ldouble_quote_reader()
  954. {
  955.     check_arg(2);
  956.     vs_pop;
  957.     read_string('"', vs_base[0]);
  958.     vs_base[0] = copy_simple_string(token);
  959. }
  960.  
  961. Ldispatch_reader()
  962. {
  963.     object c, x;
  964.     int i, d;
  965.     object in;
  966.  
  967.     check_arg(2);
  968.     
  969.     in = vs_base[0];
  970.     c = vs_base[1];
  971.  
  972.     if (READtable->rt.rt_self[char_code(c)].rte_dtab == NULL)
  973.         FEerror("~C is not a dispatching macro character", 1, c);
  974.  
  975.     c = read_char(in);
  976.     d = digitp(char_code(c), 10);
  977.     if (d >= 0) {
  978.         i = 0;
  979.         do {
  980.             i = 10*i + d;
  981.             c = read_char(in);
  982.             d = digitp(char_code(c), 10);
  983.         } while (d >= 0);
  984.         vs_push(make_fixnum(i));
  985.     } else
  986.         vs_push(Cnil);
  987.  
  988.     x =
  989.     READtable->rt.rt_self[char_code(vs_base[1])].rte_dtab[char_code(c)];
  990.     vs_base[1] = c;
  991.     super_funcall(x);
  992. }
  993.  
  994. Lsingle_quote_reader()
  995. {
  996.     check_arg(2);
  997.     vs_pop;
  998.     vs_push(Squote);
  999.     vs_push(read_object(vs_base[0]));
  1000.     vs_push(Cnil);
  1001.     stack_cons();
  1002.     stack_cons();
  1003.     vs_base[0] = vs_pop;
  1004. }
  1005.  
  1006. Lright_parenthesis_reader()
  1007. {
  1008.     check_arg(2);
  1009.     vs_pop;
  1010.     vs_pop;
  1011.         /*  no result  */
  1012. }
  1013.  
  1014. /*
  1015. Lcomma_reader(){}
  1016. */
  1017.  
  1018. Lsemicolon_reader()
  1019. {
  1020.     object c;
  1021.     object str= vs_base[0];
  1022.     check_arg(2);
  1023.     vs_pop;
  1024.     do
  1025.     { read_char_to(c,str, goto L); }
  1026.         while (char_code(c) != '\n');
  1027. L:    
  1028.     vs_pop;
  1029.     vs_base[0] = Cnil;
  1030.     /*  no result  */
  1031. }
  1032.  
  1033. /*
  1034. Lbackquote_reader(){}
  1035. */
  1036.  
  1037. /*
  1038.     sharpmacro routines
  1039. */
  1040.  
  1041. Lsharp_C_reader()
  1042. {
  1043.     object x, c;
  1044.  
  1045.     check_arg(3);
  1046.     if (vs_base[2] != Cnil && !READsuppress)
  1047.         extra_argument('C');
  1048.     vs_pop;
  1049.     vs_pop;
  1050.     c = read_char(vs_base[0]);
  1051.     if (char_code(c) != '(')
  1052.         FEerror("A left parenthesis is expected.", 0);
  1053.     delimiting_char = code_char(')');
  1054.     x = read_object(vs_base[0]);
  1055.     if (x == OBJNULL)
  1056.         FEerror("No real part.", 0);
  1057.     vs_push(x);
  1058.     delimiting_char = code_char(')');
  1059.     x = read_object(vs_base[0]);
  1060.     if (x == OBJNULL)
  1061.         FEerror("No imaginary part.", 0);
  1062.     vs_push(x);
  1063.     delimiting_char = code_char(')');
  1064.     x = read_object(vs_base[0]);
  1065.     if (x != OBJNULL)
  1066.         FEerror("A right parenthesis is expected.", 0);
  1067.     if (READsuppress) vs_base[0]= Cnil ;
  1068.          else
  1069.     if (contains_sharp_comma(vs_base[1]) ||
  1070.         contains_sharp_comma(vs_base[2])) {
  1071.         vs_base[0] = alloc_object(t_complex);
  1072.         vs_base[0]->cmp.cmp_real = vs_base[1];
  1073.         vs_base[0]->cmp.cmp_imag = vs_base[2];
  1074.     } else {
  1075.         check_type_number(&vs_base[1]);
  1076.         check_type_number(&vs_base[2]);
  1077.         vs_base[0] = make_complex(vs_base[1], vs_base[2]);
  1078.     }
  1079.     vs_top = vs_base + 1;
  1080. }
  1081.  
  1082. Lsharp_backslash_reader()
  1083. {
  1084.     object c;
  1085.  
  1086.     check_arg(3);
  1087.     if (vs_base[2] != Cnil && !READsuppress)
  1088.         if (type_of(vs_base[2]) != t_fixnum ||
  1089.             fix(vs_base[2]) != 0)
  1090.             FEerror("~S is an illegal CHAR-FONT.", 1, vs_base[2]);
  1091.             /*  assuming that CHAR-FONT-LIMIT is 1  */
  1092.     vs_pop;
  1093.     vs_pop;
  1094.     unread_char(code_char('\\'), vs_base[0]);
  1095.     if (READsuppress) {
  1096.         (void)read_object(vs_base[0]);
  1097.         vs_base[0] = Cnil;
  1098.         return;
  1099.     }
  1100.     READsuppress = TRUE;
  1101.     (void)read_object(vs_base[0]);
  1102.     READsuppress = FALSE;
  1103.     c = token;
  1104.     if (c->s.s_fillp == 1) {
  1105.         vs_base[0] = code_char(c->ust.ust_self[0]);
  1106.         return;
  1107.     }
  1108.     if (string_equal(c, STreturn))
  1109.         vs_base[0] = code_char('\r');
  1110.     else if (string_equal(c, STspace))
  1111.         vs_base[0] = code_char(' ');
  1112.     else if (string_equal(c, STrubout))
  1113.         vs_base[0] = code_char('\177');
  1114.     else if (string_equal(c, STpage))
  1115.         vs_base[0] = code_char('\f');
  1116.     else if (string_equal(c, STtab))
  1117.         vs_base[0] = code_char('\t');
  1118.     else if (string_equal(c, STbackspace))
  1119.         vs_base[0] = code_char('\b');
  1120.     else if (string_equal(c, STlinefeed) || string_equal(c, STnewline))
  1121.         vs_base[0] = code_char('\n');
  1122.     else if (c->s.s_fillp == 2 && c->s.s_self[0] == '^')
  1123.         vs_base[0] = code_char(c->s.s_self[1] & 037);
  1124.     else if (c->s.s_self[0] =='\\' && c->s.s_fillp > 1) {
  1125.         int i, n;
  1126.         for (n = 0, i = 1;  i < c->s.s_fillp;  i++)
  1127.             if (c->s.s_self[i] < '0' || '7' < c->s.s_self[i])
  1128.                 FEerror("Octal digit expected.", 0);
  1129.             else
  1130.                 n = 8*n + c->s.s_self[i] - '0';
  1131.         vs_base[0] = code_char(n & 0377);
  1132.     } else
  1133.         FEerror("~S is an illegal character name.", 1, c);
  1134. }
  1135.  
  1136. Lsharp_single_quote_reader()
  1137. {
  1138.  
  1139.     check_arg(3);
  1140.     if(vs_base[2] != Cnil && !READsuppress)
  1141.         extra_argument('#');
  1142.     vs_pop;
  1143.     vs_pop;
  1144.     vs_push(Sfunction);
  1145.     vs_push(read_object(vs_base[0]));
  1146.     vs_push(Cnil);
  1147.     stack_cons();
  1148.     stack_cons();
  1149.     vs_base[0] = vs_pop;
  1150. }
  1151.  
  1152. #define    QUOTE    1
  1153. #define    EVAL    2
  1154. #define    LIST    3
  1155. #define    LISTA    4
  1156. #define    APPEND    5
  1157. #define    NCONC    6
  1158.  
  1159. object siScomma;
  1160.  
  1161. Lsharp_left_parenthesis_reader()
  1162. {
  1163.     int dim;
  1164.     int dimcount;
  1165.     object in, x;
  1166.     int a;
  1167.     object *vsp;        
  1168.  
  1169.     check_arg(3);
  1170.     if (vs_base[2] == Cnil || READsuppress)
  1171.         dim = -1;
  1172.     else if (type_of(vs_base[2]) == t_fixnum)
  1173.         dim = fix(vs_base[2]);
  1174.     vs_pop;
  1175.     vs_pop;
  1176.     in = vs_base[0];
  1177.     if (backq_level > 0) {
  1178.         unreadc_stream('(', in);
  1179.         vs_push(read_object(in));
  1180.         a = backq_car(vs_base[1]);
  1181.         if (a == APPEND || a == NCONC)
  1182.         FEerror(",at or ,. has appeared in an illegal position.", 0);
  1183.         if (a == QUOTE) {
  1184.             vsp = vs_top;
  1185.             dimcount = 0;
  1186.             for (x = vs_base[2];  !endp(x);  x = x->c.c_cdr) {
  1187.                 vs_check_push(x->c.c_car);
  1188.                 dimcount++;
  1189.             }    
  1190.             goto L;
  1191.         }
  1192.         vs_push(siScomma);
  1193.         vs_push(Sapply);
  1194.         vs_push(Squote);
  1195.         vs_push(Svector);
  1196.         vs_push(Cnil);
  1197.         stack_cons();
  1198.         stack_cons();
  1199.         vs_push(vs_base[2]);
  1200.         vs_push(Cnil);
  1201.         stack_cons();
  1202.         stack_cons();
  1203.         stack_cons();
  1204.         stack_cons();
  1205.         vs_base = vs_top - 1;
  1206.         return;
  1207.     }
  1208.     vsp = vs_top;
  1209.     dimcount = 0;
  1210.     for (;;) {
  1211.         delimiting_char = code_char(')');
  1212.         x = read_object(in);
  1213.         if (x == OBJNULL)
  1214.             break;
  1215.         vs_check_push(x);
  1216.         dimcount++;
  1217.     }    
  1218. L:
  1219.     if (dim >= 0) {
  1220.         if (dimcount > dim)
  1221.             FEerror("Too many elements in #(...).", 0);
  1222.         else {
  1223.             if (dimcount == 0)
  1224.                 FEerror("Cannot fill the vector #().", 0);
  1225.             x = vs_head;
  1226.             for (;  dimcount < dim;  dimcount++)
  1227.                 vs_push(x);
  1228.         }
  1229.     }
  1230.     x = alloc_simple_vector(dimcount, aet_object);
  1231.     vs_push(x);
  1232.     x->v.v_self
  1233.     = (object *)alloc_relblock(dimcount * sizeof(object));
  1234.     vs_pop;
  1235.     for (dim = 0; dim < dimcount; dim++)
  1236.         x->v.v_self[dim] = vsp[dim];
  1237.     vs_top = vs_base;
  1238.     vs_push(x);
  1239. }
  1240.  
  1241. Lsharp_asterisk_reader()
  1242. {
  1243.     int dim;
  1244.     int dimcount;
  1245.     object in, x;
  1246.     object *vsp;        
  1247.  
  1248.     check_arg(3);
  1249.     if (READsuppress) {
  1250.         read_constituent(vs_base[0]);
  1251.         vs_pop;
  1252.         vs_pop;
  1253.         vs_base[0] = Cnil;
  1254.         return;
  1255.     }
  1256.     if (vs_head == Cnil)
  1257.         dim = -1;
  1258.     else if (type_of(vs_head) == t_fixnum)
  1259.         dim = fix(vs_head);
  1260.     vs_pop;
  1261.     vs_pop;
  1262.     in = vs_head;
  1263.     vsp = vs_top;
  1264.     dimcount = 0;
  1265.     for (;;) {
  1266.         if (stream_at_end(in))
  1267.             break;
  1268.         x = read_char(in);
  1269.         if (char_code(x) != '0' && char_code(x) != '1') {
  1270.             unread_char(x, in);
  1271.             break;
  1272.         }
  1273.         vs_check_push(x);
  1274.         dimcount++;
  1275.     }    
  1276.     if (dim >= 0) {
  1277.         if (dimcount > dim)
  1278.             FEerror("Too many elements in #*....", 0);
  1279.         else {
  1280.             if (dimcount == 0)
  1281.                 error("Cannot fill the bit-vector #*.");
  1282.             x = vs_head;
  1283.             for (;  dimcount < dim;  dimcount++)
  1284.                 vs_push(x);
  1285.         }
  1286.     }
  1287.     x = alloc_simple_bitvector(dimcount);
  1288.     vs_push(x);
  1289.     x->bv.bv_self = alloc_relblock((dimcount + 7)/8);
  1290.     vs_pop;
  1291.     for (dim = 0; dim < dimcount; dim++)
  1292.         if (char_code(vsp[dim]) == '0')
  1293.             x->bv.bv_self[dim/8] &= ~(0200 >> dim%8);
  1294.         else
  1295.             x->bv.bv_self[dim/8] |= 0200 >> dim%8;
  1296.     vs_top = vs_base;
  1297.     vs_push(x);
  1298. }
  1299.  
  1300. Lsharp_colon_reader()
  1301. {
  1302.     object in;
  1303.     int length;
  1304.     object c;
  1305.     enum chattrib a;
  1306.  
  1307.     if (vs_base[2] != Cnil && !READsuppress)
  1308.         extra_argument(':');
  1309.     vs_pop;
  1310.     vs_pop;
  1311.     in = vs_base[0];
  1312.     c = read_char(in);
  1313.     a = cat(c);
  1314.     escape_flag = FALSE;
  1315.     length = 0;
  1316.     goto L;
  1317.     for (;;) {
  1318.         if (length >= token->st.st_dim)
  1319.             too_long_token();
  1320.         token_buffer[length++] = char_code(c);
  1321.     K:
  1322.         if (stream_at_end(in))
  1323.             goto M;
  1324.         c = read_char(in);
  1325.         a = cat(c);
  1326.     L:
  1327.         if (a == cat_single_escape) {
  1328.             c = read_char(in);
  1329.             a = cat_constituent;
  1330.             escape_flag = TRUE;
  1331.         } else if (a == cat_multiple_escape) {
  1332.             escape_flag = TRUE;
  1333.             for (;;) {
  1334.                 if (stream_at_end(in))
  1335.                     end_of_stream(in);
  1336.                 c = read_char(in);
  1337.                 a = cat(c);
  1338.                 if (a == cat_single_escape) {
  1339.                     c = read_char(in);
  1340.                     a = cat_constituent;
  1341.                 } else if (a == cat_multiple_escape)
  1342.                     break;
  1343.                 if (length >= token->st.st_dim)
  1344.                     too_long_token();
  1345.                 token_buffer[length++] = char_code(c);
  1346.             }
  1347.             goto K;
  1348.         } else if ('a' <= char_code(c) && char_code(c) <= 'z')
  1349.             c = code_char(char_code(c) - ('a' - 'A'));
  1350.         if (a == cat_whitespace || a == cat_terminating)
  1351.             break;
  1352.     }
  1353.     if (preserving_whitespace_flag || cat(c) != cat_whitespace)
  1354.         unread_char(c, in);
  1355.  
  1356. M:
  1357.     if (READsuppress) {
  1358.         vs_base[0] = Cnil;
  1359.         return;
  1360.     }
  1361.     token->st.st_fillp = length;
  1362.     vs_base[0] = copy_simple_string(token);
  1363.     vs_base[0] = make_symbol(vs_base[0]);
  1364. }
  1365.  
  1366. Lsharp_dot_reader()
  1367. {
  1368.     check_arg(3);
  1369.     if(vs_base[2] != Cnil && !READsuppress)
  1370.         extra_argument('.');
  1371.     vs_pop;
  1372.     vs_pop;
  1373.     if (READsuppress) {
  1374.         read_object(vs_base[0]);    
  1375.         vs_base[0] = Cnil;
  1376.         return;
  1377.     }
  1378.     vs_base[0] = read_object(vs_base[0]);
  1379.     vs_base[0] = ieval(vs_base[0]);
  1380. }
  1381.  
  1382. Lsharp_comma_reader()
  1383. {
  1384.     check_arg(3);
  1385.     if(vs_base[2] != Cnil && !READsuppress)
  1386.         extra_argument(',');
  1387.     vs_pop;
  1388.     vs_pop;
  1389.     if (READsuppress) {
  1390.         read_object(vs_base[0]);
  1391.         vs_base[0] = Cnil;
  1392.         return;
  1393.     }
  1394.     vs_base[0] = read_object(vs_base[0]);
  1395.     vs_base[0] = ieval(vs_base[0]);
  1396. }
  1397.  
  1398. siLsharp_comma_reader_for_compiler()
  1399. {
  1400.     check_arg(3);
  1401.     if(vs_base[2] != Cnil && !READsuppress)
  1402.         extra_argument(',');
  1403.     vs_pop;
  1404.     vs_pop;
  1405.     if (READsuppress) {
  1406.         vs_base[0] = Cnil;
  1407.         return;
  1408.     }
  1409.     vs_base[0] = read_object(vs_base[0]);
  1410.     vs_base[0] = make_cons(siSsharp_comma, vs_base[0]);
  1411. }
  1412.  
  1413. /*
  1414.     For fasload.
  1415. */
  1416. Lsharp_exclamation_reader()
  1417. {
  1418.     check_arg(3);
  1419.     if(vs_base[2] != Cnil && !READsuppress)
  1420.         extra_argument('!');
  1421.     vs_pop;
  1422.     vs_pop;
  1423.     if (READsuppress) {
  1424.         vs_base[0] = Cnil;
  1425.         return;
  1426.     }
  1427.     vs_base[0] = read_object(vs_base[0]);
  1428.     ieval(vs_base[0]);
  1429.     vs_pop;
  1430. }
  1431.  
  1432. Lsharp_B_reader()
  1433. {
  1434.     int i;
  1435.  
  1436.     if(vs_base[2] != Cnil && !READsuppress)
  1437.         extra_argument('B');
  1438.     vs_pop;
  1439.     vs_pop;
  1440.     read_constituent(vs_base[0]);
  1441.     if (READsuppress) {
  1442.         vs_base[0] = Cnil;
  1443.         return;
  1444.     }
  1445.     vs_base[0]
  1446.     = parse_number(token_buffer, token->st.st_fillp, &i, 2);
  1447.     if (vs_base[0] == OBJNULL || i != token->st.st_fillp)
  1448.         FEerror("Cannot parse the #B readmacro.", 0);
  1449.     if (type_of(vs_base[0]) == t_shortfloat ||
  1450.         type_of(vs_base[0]) == t_longfloat)
  1451.         FEerror("The float ~S appeared after the #B readmacro.",
  1452.             1, vs_base[0]);
  1453. }
  1454.  
  1455. Lsharp_O_reader()
  1456. {
  1457.     int i;
  1458.  
  1459.     if(vs_base[2] != Cnil && !READsuppress)
  1460.         extra_argument('O');
  1461.     vs_pop;
  1462.     vs_pop;
  1463.     read_constituent(vs_base[0]);
  1464.     if (READsuppress) {
  1465.         vs_base[0] = Cnil;
  1466.         return;
  1467.     }
  1468.     vs_base[0]
  1469.     = parse_number(token_buffer, token->st.st_fillp, &i, 8);
  1470.     if (vs_base[0] == OBJNULL || i != token->st.st_fillp)
  1471.         FEerror("Cannot parse the #O readmacro.", 0);
  1472.     if (type_of(vs_base[0]) == t_shortfloat ||
  1473.         type_of(vs_base[0]) == t_longfloat)
  1474.         FEerror("The float ~S appeared after the #O readmacro.",
  1475.             1, vs_base[0]);
  1476. }
  1477.  
  1478. Lsharp_X_reader()
  1479. {
  1480.     int i;
  1481.  
  1482.     if(vs_base[2] != Cnil && !READsuppress)
  1483.         extra_argument('X');
  1484.     vs_pop;
  1485.     vs_pop;
  1486.     read_constituent(vs_base[0]);
  1487.     if (READsuppress) {
  1488.         vs_base[0] = Cnil;
  1489.         return;
  1490.     }
  1491.     vs_base[0]
  1492.     = parse_number(token_buffer, token->st.st_fillp, &i, 16);
  1493.     if (vs_base[0] == OBJNULL || i != token->st.st_fillp)
  1494.         FEerror("Cannot parse the #X readmacro.", 0);
  1495.     if (type_of(vs_base[0]) == t_shortfloat ||
  1496.         type_of(vs_base[0]) == t_longfloat)
  1497.         FEerror("The float ~S appeared after the #X readmacro.",
  1498.             1, vs_base[0]);
  1499. }
  1500.  
  1501. Lsharp_R_reader()
  1502. {
  1503.     int radix, i;
  1504.  
  1505.     check_arg(3);
  1506.     if (READsuppress)
  1507.         radix = 10;
  1508.     else if (type_of(vs_base[2]) == t_fixnum) {
  1509.         radix = fix(vs_base[2]);
  1510.         if (radix > 36 || radix < 2)
  1511.             FEerror("~S is an illegal radix.", 1, vs_base[2]);
  1512.     } else
  1513.         FEerror("No radix was supplied in the #R readmacro.", 0);
  1514.     vs_pop;
  1515.     vs_pop;
  1516.     read_constituent(vs_base[0]);
  1517.     if (READsuppress) {
  1518.         vs_base[0] = Cnil;
  1519.         return;
  1520.     }
  1521.     vs_base[0]
  1522.     = parse_number(token_buffer, token->st.st_fillp, &i, radix);
  1523.     if (vs_base[0] == OBJNULL || i != token->st.st_fillp)
  1524.         FEerror("Cannot parse the #R readmacro.", 0);
  1525.     if (type_of(vs_base[0]) == t_shortfloat ||
  1526.         type_of(vs_base[0]) == t_longfloat)
  1527.         FEerror("The float ~S appeared after the #R readmacro.",
  1528.             1, vs_base[0]);
  1529. }
  1530.  
  1531. Lsharp_A_reader(){}
  1532.  
  1533. Lsharp_S_reader(){}
  1534.  
  1535. Lsharp_eq_reader()
  1536. {
  1537.     int i;
  1538.  
  1539.     check_arg(3);
  1540.     if (READsuppress) {
  1541.         vs_top = vs_base;
  1542.         return;
  1543.     }
  1544.     if (vs_base[2] == Cnil)
  1545.         FEerror("The #= readmacro requires an argument.", 0);
  1546.     for (i = 0;  i < sharp_eq_context_max;  i++)
  1547.         if (eql(sharp_eq_context[i].sharp_index, vs_base[2]))
  1548.             FEerror("Duplicate definitions for #~D=.",
  1549.                 1, vs_base[2]);
  1550.     if (sharp_eq_context_max >= SHARP_EQ_CONTEXT_SIZE)
  1551.         FEerror("Too many #= definitions.", 0);
  1552.     i = sharp_eq_context_max++;
  1553.     sharp_eq_context[i].sharp_index = vs_base[2];
  1554.     sharp_eq_context[i].sharp_sharp = OBJNULL;
  1555.     vs_base[0]
  1556.     = sharp_eq_context[i].sharp_eq
  1557.     = read_object(vs_base[0]);
  1558.     if (sharp_eq_context[i].sharp_eq
  1559.         == sharp_eq_context[i].sharp_sharp)
  1560.         FEerror("#~D# is defined by itself.",
  1561.             1, sharp_eq_context[i].sharp_index);
  1562.     vs_top = vs_base+1;
  1563. }
  1564.  
  1565. Lsharp_sharp_reader()
  1566. {
  1567.     int i;
  1568.  
  1569.     check_arg(3);
  1570.     if (READsuppress) {
  1571.         vs_pop;
  1572.         vs_pop;
  1573.         vs_base[0] = Cnil;
  1574.     }
  1575.     if (vs_base[2] == Cnil)
  1576.         FEerror("The ## readmacro requires an argument.", 0);
  1577.     for (i = 0;  ;  i++)
  1578.         if (i >= sharp_eq_context_max)
  1579.             FEerror("#~D# is undefined.", 1, vs_base[2]);
  1580.         else if (eql(sharp_eq_context[i].sharp_index,
  1581.                  vs_base[2]))
  1582.             break;
  1583.     if (sharp_eq_context[i].sharp_sharp == OBJNULL) {
  1584.         sharp_eq_context[i].sharp_sharp
  1585.         = alloc_object(t_spice);
  1586.     }
  1587.     vs_base[0] = sharp_eq_context[i].sharp_sharp;
  1588.     vs_top = vs_base+1;
  1589. }
  1590.  
  1591. patch_sharp_cons(x)
  1592. object x;
  1593. {
  1594.     for (;;) {
  1595.         x->c.c_car = patch_sharp(x->c.c_car);
  1596.         if (type_of(x->c.c_cdr) == t_cons)
  1597.             x = x->c.c_cdr;
  1598.         else {
  1599.             x->c.c_cdr = patch_sharp(x->c.c_cdr);
  1600.             break;
  1601.         }
  1602.     }
  1603. }
  1604.  
  1605. object
  1606. patch_sharp(x)
  1607. object x;
  1608. {
  1609.     cs_check(x);
  1610.  
  1611.     switch (type_of(x)) {
  1612.     case t_spice:
  1613.     {
  1614.         int i;
  1615.  
  1616.         for (i = 0;  i < sharp_eq_context_max;  i++)
  1617.             if (sharp_eq_context[i].sharp_sharp == x)
  1618.                 return(sharp_eq_context[i].sharp_eq);
  1619.         break;
  1620.     }
  1621.     case t_cons:
  1622.     /*
  1623.         x->c.c_car = patch_sharp(x->c.c_car);
  1624.         x->c.c_cdr = patch_sharp(x->c.c_cdr);
  1625.     */
  1626.         patch_sharp_cons(x);
  1627.         break;
  1628.  
  1629.     case t_vector:
  1630.     {
  1631.         int i;
  1632.  
  1633.         if ((enum aelttype)x->v.v_elttype != aet_object)
  1634.           break;
  1635.  
  1636.         for (i = 0;  i < x->v.v_fillp;  i++)
  1637.             x->v.v_self[i] = patch_sharp(x->v.v_self[i]);
  1638.         break;
  1639.     }
  1640.     case t_array:
  1641.     {
  1642.         int i, j;
  1643.         
  1644.         if ((enum aelttype)x->a.a_elttype != aet_object)
  1645.           break;
  1646.  
  1647.         for (i = 0, j = 1;  i < x->a.a_rank;  i++)
  1648.             j *= x->a.a_dims[i];
  1649.         for (i = 0;  i < j;  i++)
  1650.             x->a.a_self[i] = patch_sharp(x->a.a_self[i]);
  1651.         break;
  1652.     }
  1653.     case t_structure:
  1654.     {object def = x->str.str_def;
  1655.      int i;
  1656.      i=S_DATA(def)->length;
  1657.      while (i--> 0)
  1658.        structure_set(x,def,i,patch_sharp(structure_ref(x,def,i)));
  1659.      break;
  1660.        }
  1661.     
  1662.     }
  1663.     return(x);
  1664. }
  1665.  
  1666. Lsharp_plus_reader(){}
  1667.  
  1668. Lsharp_minus_reader(){}
  1669.  
  1670. Lsharp_less_than_reader(){}
  1671.  
  1672. Lsharp_whitespace_reader(){}
  1673.  
  1674. Lsharp_right_parenthesis_reader(){}
  1675.  
  1676. Lsharp_vertical_bar_reader()
  1677. {
  1678.     int c;
  1679.     int level = 0;
  1680.  
  1681.     check_arg(3);
  1682.     if (vs_base[2] != Cnil && !READsuppress)
  1683.         extra_argument('|');
  1684.     vs_pop;
  1685.     vs_pop;
  1686.     for (;;) {
  1687.         c = readc_stream(vs_base[0]);
  1688.     L:
  1689.         if (c == '#') {
  1690.             c = readc_stream(vs_base[0]);
  1691.             if (c == '|')
  1692.                 level++;
  1693.         } else if (c == '|') {
  1694.             c = readc_stream(vs_base[0]);
  1695.             if (c == '#') {
  1696.                 if (level == 0)
  1697.                     break;
  1698.                 else
  1699.                     --level;
  1700.             } else
  1701.                 goto L;
  1702.         }
  1703.     }
  1704.     vs_pop;
  1705.     vs_base[0] = Cnil;
  1706.     /*  no result  */
  1707. }
  1708.  
  1709. Ldefault_dispatch_macro()
  1710. {
  1711.     FEerror("The default dispatch macro signalled an error.", 0);
  1712. }
  1713.  
  1714. /*
  1715.     #" ... " returns the pathname with namestring ... .
  1716. */
  1717. Lsharp_double_quote_reader()
  1718. {
  1719.     check_arg(3);
  1720.  
  1721.     if (vs_base[2] != Cnil && !READsuppress)
  1722.         extra_argument('"');
  1723.     vs_pop;
  1724.     unread_char(vs_base[1], vs_base[0]);
  1725.     vs_pop;
  1726.     vs_base[0] = read_object(vs_base[0]);
  1727.     vs_base[0] = coerce_to_pathname(vs_base[0]);
  1728. }
  1729.  
  1730. /*
  1731.     #$ fixnum returns a random-state with the fixnum
  1732.     as its content.
  1733. */
  1734. Lsharp_dollar_reader()
  1735. {
  1736.     int i;
  1737.  
  1738.     check_arg(3);
  1739.     if (vs_base[2] != Cnil && !READsuppress)
  1740.         extra_argument('$');
  1741.     vs_pop;
  1742.     vs_pop;
  1743.     vs_base[0] = read_object(vs_base[0]);
  1744.     if (type_of(vs_base[0]) != t_fixnum)
  1745.         FEerror("Cannot make a random-state with the value ~S.",
  1746.             1, vs_base[0]);
  1747.     i = fix(vs_base[0]);
  1748.     vs_base[0] = alloc_object(t_random);
  1749.     vs_base[0]->rnd.rnd_value = i;
  1750. }
  1751.  
  1752. /*
  1753.     readtable routines
  1754. */
  1755.  
  1756. object
  1757. copy_readtable(from, to)
  1758. object from, to;
  1759. {
  1760.     struct rtent *rtab;
  1761.     int i, j;
  1762.     vs_mark;
  1763.  
  1764.     if (to == Cnil) {
  1765.         to = alloc_object(t_readtable);
  1766.         to->rt.rt_self = NULL;
  1767.             /*  For GBC not to go mad.  */
  1768.         vs_push(to);
  1769.             /*  Saving for GBC.  */
  1770.         to->rt.rt_self
  1771.         = rtab
  1772.          = (struct rtent *)
  1773.           alloc_contblock(RTABSIZE * sizeof(struct rtent));
  1774.         for (i = 0;  i < RTABSIZE;  i++)
  1775.             rtab[i] = from->rt.rt_self[i];
  1776.                 /*  structure assignment  */
  1777.     } else
  1778.      rtab=to->rt.rt_self;
  1779.     for (i = 0;  i < RTABSIZE;  i++)
  1780.         if (from->rt.rt_self[i].rte_dtab != NULL) {
  1781.             rtab[i].rte_dtab
  1782.              = (object *)
  1783.               alloc_contblock(RTABSIZE * sizeof(object));
  1784.             for (j = 0;  j < RTABSIZE;  j++)
  1785.                 rtab[i].rte_dtab[j]
  1786.                 = from->rt.rt_self[i].rte_dtab[j];
  1787.         }
  1788.     vs_reset;
  1789.     return(to);
  1790. }
  1791.  
  1792. object
  1793. current_readtable()
  1794. {
  1795.     object r;
  1796.  
  1797.     r = symbol_value(Vreadtable);
  1798.     if (type_of(r) != t_readtable) {
  1799.         Vreadtable->s.s_dbind = copy_readtable(standard_readtable);
  1800.         FEerror("The value of *READTABLE*, ~S, was not a readtable.",
  1801.             1, r);
  1802.     }
  1803.     return(r);
  1804. }
  1805.  
  1806.  
  1807. @(defun read (&optional (strm `symbol_value(Vstandard_input)`)
  1808.             (eof_errorp Ct)
  1809.             eof_value
  1810.             recursivep
  1811.           &aux x)
  1812. @
  1813.     if (strm == Cnil)
  1814.         strm = symbol_value(Vstandard_input);
  1815.     else if (strm == Ct)
  1816.         strm = symbol_value(Vterminal_io);
  1817.     check_type_stream(&strm);
  1818.     if (recursivep == Cnil)
  1819.         preserving_whitespace_flag = FALSE;
  1820.     detect_eos_flag = TRUE;
  1821.     if (recursivep == Cnil)
  1822.         x = read_object_non_recursive(strm);
  1823.     else
  1824.         x = read_object_recursive(strm);
  1825.     if (x == OBJNULL) {
  1826.         if (eof_errorp == Cnil && recursivep == Cnil)
  1827.             @(return eof_value)
  1828.         end_of_stream(strm);
  1829.     }
  1830.     @(return x)
  1831. @)
  1832.  
  1833. @(defun read_preserving_whitespace
  1834.     (&optional (strm `symbol_value(Vstandard_input)`)
  1835.            (eof_errorp Ct)
  1836.            eof_value
  1837.            recursivep
  1838.      &aux x)
  1839.     object c;
  1840. @
  1841.     if (strm == Cnil)
  1842.         strm = symbol_value(Vstandard_input);
  1843.     else if (strm == Ct)
  1844.         strm = symbol_value(Vterminal_io);
  1845.     check_type_stream(&strm);
  1846.     while (!stream_at_end(strm)) {
  1847.         c = read_char(strm);
  1848.         if (cat(c) != cat_whitespace) {
  1849.             unread_char(c, strm);
  1850.             goto READ;
  1851.         }
  1852.     }
  1853.     if (eof_errorp == Cnil && recursivep == Cnil)
  1854.         @(return eof_value)
  1855.     end_of_stream(strm);
  1856.  
  1857. READ:
  1858.     if (recursivep == Cnil)
  1859.         preserving_whitespace_flag = TRUE;
  1860.     if (recursivep == Cnil)
  1861.         x = read_object_non_recursive(strm);
  1862.     else
  1863.         x = read_object_recursive(strm);
  1864.     @(return x)
  1865. @)
  1866.  
  1867. @(defun read_delimited_list
  1868.     (d
  1869.      &optional (strm `symbol_value(Vstandard_input)`)
  1870.            recursivep
  1871.      &aux l x)
  1872.  
  1873.     object *p;
  1874.  
  1875.     int i;
  1876.     bool e;
  1877.     int old_sharp_eq_context_max;
  1878.     struct sharp_eq_context_struct
  1879.         old_sharp_eq_context[SHARP_EQ_CONTEXT_SIZE];
  1880.     int old_backq_level;
  1881.  
  1882. @
  1883.  
  1884.     check_type_character(&d);
  1885.     if (strm == Cnil)
  1886.         strm = symbol_value(Vstandard_input);
  1887.     else if (strm == Ct)
  1888.         strm = symbol_value(Vterminal_io);
  1889.     check_type_stream(&strm);
  1890.     if (recursivep == Cnil) {
  1891.         old_sharp_eq_context_max = sharp_eq_context_max;
  1892.         for (i = 0;  i < sharp_eq_context_max;  i++)
  1893.             old_sharp_eq_context[i] = sharp_eq_context[i];
  1894.         old_backq_level = backq_level;
  1895.         setup_READ();
  1896.         frs_push(FRS_PROTECT, Cnil);
  1897.         if (nlj_active) {
  1898.             e = TRUE;
  1899.             goto L;
  1900.         }
  1901.     }
  1902.     l = Cnil;
  1903.     p = &l;
  1904.     preserving_whitespace_flag = FALSE;    /*  necessary?  */
  1905.     for (;;) {
  1906.         delimiting_char = d;
  1907.         x = read_object_recursive(strm);
  1908.         if (x == OBJNULL)
  1909.             break;
  1910.         *p = make_cons(x, Cnil);
  1911.         p = &((*p)->c.c_cdr);
  1912.     }
  1913.     if (recursivep == Cnil) {
  1914.         if (sharp_eq_context_max > 0)
  1915.             l = patch_sharp(l);
  1916.         e = FALSE;
  1917.     L:
  1918.         frs_pop();
  1919.         sharp_eq_context_max = old_sharp_eq_context_max;
  1920.         for (i = 0;  i < sharp_eq_context_max;  i++)
  1921.             sharp_eq_context[i] = old_sharp_eq_context[i];
  1922.         backq_level = old_backq_level;
  1923.         if (e) {
  1924.             nlj_active = FALSE;
  1925.             unwind(nlj_fr, nlj_tag);
  1926.         }
  1927.     }
  1928.     @(return l)
  1929. @)
  1930.  
  1931. @(defun read_line (&optional (strm `symbol_value(Vstandard_input)`)
  1932.                  (eof_errorp Ct)
  1933.                  eof_value
  1934.                  recursivep
  1935.            &aux c)
  1936.     int i;
  1937. @
  1938.     if (strm == Cnil)
  1939.         strm = symbol_value(Vstandard_input);
  1940.     else if (strm == Ct)
  1941.         strm = symbol_value(Vterminal_io);
  1942.     check_type_stream(&strm);
  1943.     if (stream_at_end(strm)) {
  1944.         if (eof_errorp == Cnil && recursivep == Cnil)
  1945.             @(return eof_value)
  1946.         else
  1947.             end_of_stream(strm);
  1948.     }
  1949.     i = 0;
  1950.     for (;;) {
  1951.             read_char_to(c,strm,c = Ct; goto FINISH);
  1952.         if (char_code(c) == '\n') {
  1953.             c = Cnil;
  1954.             break;
  1955.         }
  1956.         if (i >= token->st.st_dim)
  1957.             too_long_string();
  1958.         token->st.st_self[i++] = char_code(c);
  1959.     }
  1960.  FINISH:
  1961. #ifdef DOES_CRLF
  1962.     if (i > 0 && token->st.st_self[i-1] == '\r') i--;
  1963. #endif
  1964.     token->st.st_fillp = i;
  1965.   /* no disadvantage to returning an adjustable string */
  1966.   
  1967.   {object uu= copy_simple_string(token);
  1968. /*   uu->st.st_hasfillp=TRUE;
  1969.    uu->st.st_adjustable=TRUE;
  1970. */
  1971.    @(return uu c)
  1972.    }
  1973. @)
  1974.  
  1975. @(defun read_char (&optional (strm `symbol_value(Vstandard_input)`)
  1976.                  (eof_errorp Ct)
  1977.                  eof_value
  1978.                  recursivep)
  1979. @
  1980.     if (strm == Cnil)
  1981.         strm = symbol_value(Vstandard_input);
  1982.     else if (strm == Ct)
  1983.         strm = symbol_value(Vterminal_io);
  1984.     check_type_stream(&strm);
  1985.     if (stream_at_end(strm)) {
  1986.         if (eof_errorp == Cnil && recursivep == Cnil)
  1987.             @(return eof_value)
  1988.         else
  1989.             end_of_stream(strm);
  1990.     }
  1991.     @(return `read_char(strm)`)
  1992. @)
  1993.  
  1994. @(defun unread_char (c &optional (strm `symbol_value(Vstandard_input)`))
  1995. @
  1996.     check_type_character(&c);
  1997.     if (strm == Cnil)
  1998.         strm = symbol_value(Vstandard_input);
  1999.     else if (strm == Ct)
  2000.         strm = symbol_value(Vterminal_io);
  2001.     check_type_stream(&strm);
  2002.     unread_char(c, strm);
  2003.     @(return Cnil)
  2004. @)
  2005.  
  2006. @(defun peek_char (&optional peek_type
  2007.                  (strm `symbol_value(Vstandard_input)`)
  2008.                  (eof_errorp Ct)
  2009.                  eof_value
  2010.                  recursivep)
  2011.     object c;
  2012. @
  2013.     if (strm == Cnil)
  2014.         strm = symbol_value(Vstandard_input);
  2015.     else if (strm == Ct)
  2016.         strm = symbol_value(Vterminal_io);
  2017.     check_type_stream(&strm);
  2018.     setup_READtable();
  2019.     if (peek_type == Cnil) {
  2020.         if (stream_at_end(strm)) {
  2021.             if (eof_errorp == Cnil && recursivep == Cnil)
  2022.                 @(return eof_value)
  2023.             else
  2024.                 end_of_stream(strm);
  2025.         }
  2026.         c = read_char(strm);
  2027.         unread_char(c, strm);
  2028.         @(return c)
  2029.     }
  2030.     if (peek_type == Ct) {
  2031.         while (!stream_at_end(strm)) {
  2032.             c = read_char(strm);
  2033.             if (cat(c) != cat_whitespace) {
  2034.                 unread_char(c, strm);
  2035.                 @(return c)
  2036.             }
  2037.         }
  2038.         if (eof_errorp == Cnil)
  2039.             @(return eof_value)
  2040.         else
  2041.             end_of_stream(strm);
  2042.     }
  2043.     check_type_character(&peek_type);
  2044.     while (!stream_at_end(strm)) {
  2045.         c = read_char(strm);
  2046.         if (char_eq(c, peek_type)) {
  2047.             unread_char(c, strm);
  2048.             @(return c)
  2049.         }
  2050.     }
  2051.     if (eof_errorp == Cnil)
  2052.         @(return eof_value)
  2053.     else
  2054.         end_of_stream(strm);
  2055. @)
  2056.  
  2057. @(defun listen (&optional (strm `symbol_value(Vstandard_input)`))
  2058. @
  2059.     if (strm == Cnil)
  2060.         strm = symbol_value(Vstandard_input);
  2061.     else if (strm == Ct)
  2062.         strm = symbol_value(Vterminal_io);
  2063.     check_type_stream(&strm);
  2064.     if (listen_stream(strm))
  2065.         @(return Ct)
  2066.     else
  2067.         @(return Cnil)
  2068. @)
  2069.  
  2070. @(defun read_char_no_hang (&optional (strm `symbol_value(Vstandard_input)`)
  2071.                          (eof_errorp Ct)
  2072.                          eof_value
  2073.                          recursivep)
  2074. @
  2075.     if (strm == Cnil)
  2076.         strm = symbol_value(Vstandard_input);
  2077.     else if (strm == Ct)
  2078.         strm = symbol_value(Vterminal_io);
  2079.     check_type_stream(&strm);
  2080.     if (!listen_stream(strm))
  2081.         /* Incomplete! */
  2082.         @(return Cnil)
  2083.     @(return `read_char(strm)`)
  2084. @)
  2085.  
  2086. @(defun clear_input (&optional (strm `symbol_value(Vstandard_input)`))
  2087. @
  2088.     if (strm == Cnil)
  2089.         strm = symbol_value(Vstandard_input);
  2090.     else if (strm == Ct)
  2091.         strm = symbol_value(Vterminal_io);
  2092.     check_type_stream(&strm);
  2093. #ifdef LISTEN_FOR_INPUT
  2094.     while(listen_stream(strm)) {read_char(strm);}
  2095. #endif
  2096.     @(return Cnil)
  2097. @)
  2098.  
  2099. @(defun parse_integer (strng
  2100.                &key start
  2101.                 end
  2102.                 (radix `make_fixnum(10)`)
  2103.                 junk_allowed
  2104.                &aux x)
  2105.     int s, e, ep;
  2106. @
  2107.     check_type_string(&strng);
  2108.     get_string_start_end(strng, start, end, &s, &e);
  2109.     if (type_of(radix) != t_fixnum ||
  2110.         fix(radix) < 2 || fix(radix) > 36)
  2111.         FEerror("~S is an illegal radix.", 1, radix);
  2112.     setup_READtable();
  2113.     while (READtable->rt.rt_self[strng->st.st_self[s]].rte_chattrib
  2114.            == cat_whitespace && s < e)
  2115.         s++;
  2116.     if (s >= e) {
  2117.         if (junk_allowed != Cnil)
  2118.             @(return Cnil `make_fixnum(s)`)
  2119.         else
  2120.             goto CANNOT_PARSE;
  2121.     }
  2122.     x = parse_integer(strng->st.st_self+s, e-s, &ep, fix(radix));
  2123.     if (x == OBJNULL) {
  2124.         if (junk_allowed != Cnil)
  2125.             @(return Cnil `make_fixnum(ep+s)`)
  2126.         else
  2127.             goto CANNOT_PARSE;
  2128.     }
  2129.     if (junk_allowed != Cnil)
  2130.         @(return x `make_fixnum(ep+s)`)
  2131.     for (s += ep ;  s < e;  s++)
  2132.         if (READtable->rt.rt_self[strng->st.st_self[s]]
  2133.             .rte_chattrib
  2134.             != cat_whitespace)
  2135.             goto CANNOT_PARSE;
  2136.     @(return x `make_fixnum(e)`)
  2137.  
  2138. CANNOT_PARSE:
  2139.     FEerror("Cannot parse an integer in the string ~S.", 1, strng);
  2140. @)
  2141.  
  2142. @(defun read_byte (binary_input_stream
  2143.            &optional eof_errorp eof_value)
  2144.     int c;
  2145. @
  2146.     check_type_stream(&binary_input_stream);
  2147.     if (stream_at_end(binary_input_stream)) {
  2148.         if (eof_errorp == Cnil)
  2149.             @(return eof_value)
  2150.         else
  2151.             end_of_stream(binary_input_stream);
  2152.     }
  2153.     c = readc_stream(binary_input_stream);
  2154.     @(return `make_fixnum(c)`)
  2155. @)
  2156.  
  2157. object
  2158. read_byte1(str,eof)
  2159. object str,eof;
  2160. {if (stream_at_end(str))
  2161.    return eof;
  2162.  return make_fixnum(readc_stream(str));}
  2163.  
  2164. object
  2165. read_char1(str,eof)
  2166. object str,eof;
  2167. {if (stream_at_end(str))
  2168.    return eof;
  2169.  return code_char(readc_stream(str));}
  2170.  
  2171.  
  2172. @(defun copy_readtable (&o (from `current_readtable()`) to)
  2173. @
  2174.     if (from == Cnil) {
  2175.         from = standard_readtable;
  2176.         if (to != Cnil)
  2177.             check_type_readtable(&to);
  2178.         to = copy_readtable(from, to);
  2179.         to->rt.rt_self['#'].rte_dtab['!']
  2180.         = default_dispatch_macro;
  2181.         /*  We must forget #! macro.  */
  2182.         @(return to)
  2183.     }
  2184.     check_type_readtable(&from);
  2185.     if (to != Cnil)
  2186.         check_type_readtable(&to);
  2187.     @(return `copy_readtable(from, to)`)
  2188. @)
  2189.  
  2190. Lreadtablep()
  2191. {
  2192.     check_arg(1);
  2193.  
  2194.     if (type_of(vs_base[0]) == t_readtable)
  2195.         vs_base[0] = Ct;
  2196.     else
  2197.         vs_base[0] = Cnil;
  2198. }
  2199.  
  2200. @(defun set_syntax_from_char (tochr fromchr
  2201.                   &o (tordtbl `current_readtable()`)
  2202.                  fromrdtbl)
  2203.     int i;
  2204. @
  2205.     check_type_character(&tochr);
  2206.     check_type_character(&fromchr);
  2207.     check_type_readtable(&tordtbl);
  2208.     if (fromrdtbl == Cnil)
  2209.         fromrdtbl = standard_readtable;
  2210.     else
  2211.         check_type_readtable(&fromrdtbl);
  2212.     tordtbl->rt.rt_self[char_code(tochr)].rte_chattrib
  2213.     = fromrdtbl->rt.rt_self[char_code(fromchr)].rte_chattrib;
  2214.     tordtbl->rt.rt_self[char_code(tochr)].rte_macro
  2215.     = fromrdtbl->rt.rt_self[char_code(fromchr)].rte_macro;
  2216.     if ((tordtbl->rt.rt_self[char_code(tochr)].rte_dtab
  2217.          = fromrdtbl->rt.rt_self[char_code(fromchr)].rte_dtab)
  2218.         != NULL) {
  2219.         tordtbl->rt.rt_self[char_code(tochr)].rte_dtab
  2220.         = (object *)
  2221.           alloc_contblock(RTABSIZE * sizeof(object));
  2222.         for (i = 0;  i < RTABSIZE;  i++)
  2223.             tordtbl->rt.rt_self[char_code(tochr)]
  2224.             .rte_dtab[i]
  2225.             = fromrdtbl->rt.rt_self[char_code(fromchr)]
  2226.               .rte_dtab[i];
  2227.     }
  2228.     @(return Ct)
  2229. @)
  2230.  
  2231. @(defun set_macro_character (chr fnc
  2232.                  &optional ntp
  2233.                        (rdtbl `current_readtable()`))
  2234.     int c;
  2235. @
  2236.     check_type_character(&chr);
  2237.     check_type_readtable(&rdtbl);
  2238.     c = char_code(chr);
  2239.     if (ntp != Cnil)
  2240.         rdtbl->rt.rt_self[c].rte_chattrib
  2241.         = cat_non_terminating;
  2242.     else
  2243.         rdtbl->rt.rt_self[c].rte_chattrib
  2244.         = cat_terminating;
  2245.     rdtbl->rt.rt_self[c].rte_macro = fnc;
  2246.     @(return Ct)
  2247. @)
  2248.  
  2249. @(defun get_macro_character (chr &o (rdtbl `current_readtable()`))
  2250.     object m;
  2251. @
  2252.     check_type_character(&chr);
  2253.     check_type_readtable(&rdtbl);
  2254.     if ((m = rdtbl->rt.rt_self[char_code(chr)].rte_macro)
  2255.         == OBJNULL)
  2256.         @(return Cnil)
  2257.     if (rdtbl->rt.rt_self[char_code(chr)].rte_chattrib
  2258.         == cat_non_terminating)
  2259.         @(return m Ct)
  2260.     else
  2261.         @(return m Cnil)
  2262. @)
  2263.  
  2264. @(defun make_dispatch_macro_character (chr
  2265.     &optional ntp (rdtbl `current_readtable()`))
  2266.     int i;
  2267. @
  2268.     check_type_character(&chr);
  2269.     check_type_readtable(&rdtbl);
  2270.     if (ntp != Cnil)
  2271.         rdtbl->rt.rt_self[char_code(chr)].rte_chattrib
  2272.         = cat_non_terminating;
  2273.     else
  2274.         rdtbl->rt.rt_self[char_code(chr)].rte_chattrib
  2275.         = cat_terminating;
  2276.     rdtbl->rt.rt_self[char_code(chr)].rte_dtab
  2277.     = (object *)
  2278.       alloc_contblock(RTABSIZE * sizeof(object));
  2279.     for (i = 0;  i < RTABSIZE;  i++)
  2280.         rdtbl->rt.rt_self[char_code(chr)].rte_dtab[i]
  2281.         = default_dispatch_macro;
  2282.     rdtbl->rt.rt_self[char_code(chr)].rte_macro = dispatch_reader;
  2283.     @(return Ct)
  2284. @)
  2285.  
  2286. @(defun set_dispatch_macro_character (dspchr subchr fnc
  2287.     &optional (rdtbl `current_readtable()`))
  2288. @
  2289.     check_type_character(&dspchr);
  2290.     check_type_character(&subchr);
  2291.     check_type_readtable(&rdtbl);
  2292.     if (rdtbl->rt.rt_self[char_code(dspchr)].rte_macro != dispatch_reader
  2293.         || rdtbl->rt.rt_self[char_code(dspchr)].rte_dtab == NULL)
  2294.         FEerror("~S is not a dispatch character.", 1, dspchr);
  2295.     rdtbl->rt.rt_self[char_code(dspchr)]
  2296.     .rte_dtab[char_code(subchr)] = fnc;
  2297.     if ('a' <= char_code(subchr) && char_code(subchr) <= 'z')
  2298.         rdtbl->rt.rt_self[char_code(dspchr)]
  2299.         .rte_dtab[char_code(subchr) - ('a' - 'A')] = fnc;
  2300.  
  2301.     @(return Ct)
  2302. @)
  2303.  
  2304. @(defun get_dispatch_macro_character (dspchr subchr
  2305.     &optional (rdtbl `current_readtable()`))
  2306. @
  2307.     check_type_character(&dspchr);
  2308.     check_type_character(&subchr);
  2309.     check_type_readtable(&rdtbl);
  2310.     if (rdtbl->rt.rt_self[char_code(dspchr)].rte_macro != dispatch_reader
  2311.         || rdtbl->rt.rt_self[char_code(dspchr)].rte_dtab == NULL)
  2312.         FEerror("~S is not a dispatch character.", 1, dspchr);
  2313.     if (digitp(char_code(subchr),10) >= 0) @(return Cnil)
  2314.     else @(return `rdtbl->rt.rt_self[char_code(dspchr)]
  2315.           .rte_dtab[char_code(subchr)]`)
  2316. @)
  2317.  
  2318. object
  2319. string_to_object(x)
  2320. object x;
  2321. {
  2322.     object in;
  2323.     vs_mark;
  2324.  
  2325.     in = make_string_input_stream(x, 0, x->st.st_fillp);
  2326.     vs_push(in);
  2327.     preserving_whitespace_flag = FALSE;
  2328.     detect_eos_flag = FALSE;
  2329.     x = read_object_non_recursive(in);
  2330.     vs_reset;
  2331.     return(x);
  2332. }
  2333.     
  2334. siLstring_to_object()
  2335. {
  2336.     check_arg(1);
  2337.  
  2338.     check_type_string(&vs_base[0]);
  2339.     vs_base[0] = string_to_object(vs_base[0]);
  2340. }
  2341.  
  2342.  
  2343. siLstandard_readtable()
  2344. {
  2345.     check_arg(0);
  2346.  
  2347.     vs_push(standard_readtable);
  2348. }
  2349.  
  2350. too_long_token()
  2351. {
  2352.     char *q;
  2353.     int i;
  2354.  
  2355.     q = alloc_contblock(token->st.st_dim*2);
  2356.     for (i = 0;  i < token->st.st_dim;  i++)
  2357.         q[i] = token->st.st_self[i];
  2358.     token->st.st_self = q;
  2359.     token->st.st_dim *= 2;
  2360. /*
  2361.     token->st.st_fillp = token->st.st_dim;
  2362.     FEerror("Too long a token: ~A.", 1, token);
  2363. */
  2364. }
  2365.  
  2366. too_long_string()
  2367. {
  2368.     char *q;
  2369.     int i;
  2370.  
  2371.     q = alloc_contblock(token->st.st_dim*2);
  2372.     for (i = 0;  i < token->st.st_dim;  i++)
  2373.         q[i] = token->st.st_self[i];
  2374.     token->st.st_self = q;
  2375.     token->st.st_dim *= 2;
  2376. /*
  2377.     token->st.st_fillp = token->st.st_dim;
  2378.     FEerror("Too long a string: ~S.", 1, token);
  2379. */
  2380. }
  2381.  
  2382. extra_argument(c)
  2383. int c;
  2384. {
  2385.     FEerror("~S is an extra argument for the #~C readmacro.",
  2386.         2, vs_base[2], code_char(c));
  2387. }
  2388.  
  2389.  
  2390. #define    make_cf(f)    make_cfun((f), Cnil, Cnil, NULL, 0)
  2391.  
  2392. init_read()
  2393. {
  2394.     struct rtent *rtab;
  2395.     object *dtab;
  2396.     int i;
  2397.  
  2398.     standard_readtable = alloc_object(t_readtable);
  2399.     enter_mark_origin(&standard_readtable);
  2400.  
  2401.     standard_readtable->rt.rt_self
  2402.     = rtab
  2403.     = (struct rtent *)
  2404.       alloc_contblock(RTABSIZE * sizeof(struct rtent));
  2405.     for (i = 0;  i < RTABSIZE;  i++) {
  2406.         rtab[i].rte_chattrib = cat_constituent;
  2407.         rtab[i].rte_macro = OBJNULL;
  2408.         rtab[i].rte_dtab = NULL;
  2409.     }
  2410.  
  2411.     dispatch_reader = make_cf(Ldispatch_reader);
  2412.     enter_mark_origin(&dispatch_reader);
  2413.  
  2414.     rtab['\t'].rte_chattrib = cat_whitespace;
  2415.     rtab['\n'].rte_chattrib = cat_whitespace;
  2416.     rtab['\f'].rte_chattrib = cat_whitespace;
  2417.     rtab['\r'].rte_chattrib = cat_whitespace;
  2418.     rtab[' '].rte_chattrib = cat_whitespace;
  2419.     rtab['"'].rte_chattrib = cat_terminating;
  2420.     rtab['"'].rte_macro = make_cf(Ldouble_quote_reader);
  2421.     rtab['#'].rte_chattrib = cat_non_terminating;
  2422.     rtab['#'].rte_macro = dispatch_reader;
  2423.     rtab['\''].rte_chattrib = cat_terminating;
  2424.     rtab['\''].rte_macro = make_cf(Lsingle_quote_reader);
  2425.     rtab['('].rte_chattrib = cat_terminating;
  2426.     rtab['('].rte_macro = make_cf(Lleft_parenthesis_reader);
  2427.     rtab[')'].rte_chattrib = cat_terminating;
  2428.     rtab[')'].rte_macro = make_cf(Lright_parenthesis_reader);
  2429. /*
  2430.     rtab[','].rte_chattrib = cat_terminating;
  2431.     rtab[','].rte_macro = make_cf(Lcomma_reader);
  2432. */
  2433.     rtab[';'].rte_chattrib = cat_terminating;
  2434.     rtab[';'].rte_macro = make_cf(Lsemicolon_reader);
  2435.     rtab['\\'].rte_chattrib = cat_single_escape;
  2436. /*
  2437.     rtab['`'].rte_chattrib = cat_terminating;
  2438.     rtab['`'].rte_macro = make_cf(Lbackquote_reader);
  2439. */
  2440.     rtab['|'].rte_chattrib = cat_multiple_escape;
  2441. /*
  2442.     rtab['|'].rte_macro = make_cf(Lvertical_bar_reader);
  2443. */
  2444.  
  2445.     default_dispatch_macro = make_cf(Ldefault_dispatch_macro);
  2446.  
  2447.     rtab['#'].rte_dtab
  2448.     = dtab
  2449.     = (object *)alloc_contblock(RTABSIZE * sizeof(object));
  2450.     for (i = 0;  i < RTABSIZE;  i++)
  2451.         dtab[i] = default_dispatch_macro;
  2452.     dtab['C'] = dtab['c'] = make_cf(Lsharp_C_reader);
  2453.     dtab['\\'] = make_cf(Lsharp_backslash_reader);
  2454.     dtab['\''] = make_cf(Lsharp_single_quote_reader);
  2455.     dtab['('] = make_cf(Lsharp_left_parenthesis_reader);
  2456.     dtab['*'] = make_cf(Lsharp_asterisk_reader);
  2457.     dtab[':'] = make_cf(Lsharp_colon_reader);
  2458.     dtab['.'] = make_cf(Lsharp_dot_reader);
  2459.     dtab['!'] = make_cf(Lsharp_exclamation_reader);
  2460.     /*  Used for fasload only. */
  2461.     dtab[','] = make_cf(Lsharp_comma_reader);
  2462.     dtab['B'] = dtab['b'] = make_cf(Lsharp_B_reader);
  2463.     dtab['O'] = dtab['o'] = make_cf(Lsharp_O_reader);
  2464.     dtab['X'] = dtab['x'] = make_cf(Lsharp_X_reader);
  2465.     dtab['R'] = dtab['r'] = make_cf(Lsharp_R_reader);
  2466. /*
  2467.     dtab['A'] = dtab['a'] = make_cf(Lsharp_A_reader);
  2468.     dtab['S'] = dtab['s'] = make_cf(Lsharp_S_reader);
  2469. */
  2470.     dtab['A'] = dtab['a'] = make_si_ordinary("SHARP-A-READER");
  2471.     dtab['S'] = dtab['s'] = make_si_ordinary("SHARP-S-READER");
  2472.  
  2473.     dtab['='] = make_cf(Lsharp_eq_reader);
  2474.     dtab['#'] = make_cf(Lsharp_sharp_reader);
  2475.     dtab['+'] = make_cf(Lsharp_plus_reader);
  2476.     dtab['-'] = make_cf(Lsharp_minus_reader);
  2477. /*
  2478.     dtab['<'] = make_cf(Lsharp_less_than_reader);
  2479. */
  2480.     dtab['|'] = make_cf(Lsharp_vertical_bar_reader);
  2481.     dtab['"'] = make_cf(Lsharp_double_quote_reader);
  2482.     /*  This is specific to this implimentation  */
  2483.     dtab['$'] = make_cf(Lsharp_dollar_reader);
  2484.     /*  This is specific to this implimentation  */
  2485. /*
  2486.     dtab[' '] = dtab['\t'] = dtab['\n'] = dtab['\f']
  2487.     = make_cf(Lsharp_whitespace_reader);
  2488.     dtab[')'] = make_cf(Lsharp_right_parenthesis_reader);
  2489. */
  2490.  
  2491.     init_backq();
  2492.  
  2493.     Vreadtable
  2494.      = make_special("*READTABLE*",
  2495.                copy_readtable(standard_readtable, Cnil));
  2496.     Vreadtable->s.s_dbind->rt.rt_self['#'].rte_dtab['!']
  2497.     = default_dispatch_macro;
  2498.     /*  We must forget #! macro.  */
  2499.     Vread_default_float_format
  2500.     = make_special("*READ-DEFAULT-FLOAT-FORMAT*",
  2501.                Ssingle_float);
  2502.     Vread_base = make_special("*READ-BASE*", make_fixnum(10));
  2503.     Vread_suppress = make_special("*READ-SUPPRESS*", Cnil);
  2504.  
  2505.     Kstart = make_keyword("START");
  2506.     Kend = make_keyword("END");
  2507.     Kradix = make_keyword("RADIX");
  2508.     Kjunk_allowed = make_keyword("JUNK-ALLOWED");
  2509.  
  2510.     READtable = symbol_value(Vreadtable);
  2511.     enter_mark_origin(&READtable);
  2512.     READdefault_float_format = 'F';
  2513.     READbase = 10;
  2514.     READsuppress = FALSE;
  2515.  
  2516.     sharp_eq_context_max = 0;
  2517.  
  2518.     siSsharp_comma = make_si_ordinary("#,");
  2519.     enter_mark_origin(&siSsharp_comma);
  2520.  
  2521.     delimiting_char = OBJNULL;
  2522.     enter_mark_origin(&delimiting_char);
  2523.  
  2524.     detect_eos_flag = FALSE;
  2525.     in_list_flag = FALSE;
  2526.     dot_flag = FALSE;
  2527.  
  2528.     big_register_0 = alloc_object(t_bignum);
  2529.     ZERO_BIG(big_register_0);
  2530.  
  2531.     enter_mark_origin(&big_register_0);
  2532. /*
  2533.     NOTE:
  2534.  
  2535.         The value of big_register_0 changes
  2536.         along the execution of the read routines.
  2537. */
  2538. }
  2539.  
  2540. init_read_function()
  2541. {
  2542.     make_function("READ", Lread);
  2543.     make_function("READ-PRESERVING-WHITESPACE",
  2544.               Lread_preserving_whitespace);
  2545.     make_function("READ-DELIMITED-LIST", Lread_delimited_list);
  2546.     make_function("READ-LINE", Lread_line);
  2547.     make_function("READ-CHAR", Lread_char);
  2548.     make_function("UNREAD-CHAR", Lunread_char);
  2549.     make_function("PEEK-CHAR", Lpeek_char);
  2550.     make_function("LISTEN", Llisten);
  2551.     make_function("READ-CHAR-NO-HANG", Lread_char_no_hang);
  2552.     make_function("CLEAR-INPUT", Lclear_input);
  2553.  
  2554.     make_function("PARSE-INTEGER", Lparse_integer);
  2555.  
  2556.     make_function("READ-BYTE", Lread_byte);
  2557.  
  2558.     make_function("COPY-READTABLE", Lcopy_readtable);
  2559.     make_function("READTABLEP", Lreadtablep);
  2560.     make_function("SET-SYNTAX-FROM-CHAR", Lset_syntax_from_char);
  2561.     make_function("SET-MACRO-CHARACTER", Lset_macro_character);
  2562.     make_function("GET-MACRO-CHARACTER", Lget_macro_character);
  2563.     make_function("MAKE-DISPATCH-MACRO-CHARACTER",
  2564.               Lmake_dispatch_macro_character);
  2565.     make_function("SET-DISPATCH-MACRO-CHARACTER",
  2566.               Lset_dispatch_macro_character);
  2567.     make_function("GET-DISPATCH-MACRO-CHARACTER",
  2568.               Lget_dispatch_macro_character);
  2569.  
  2570.     make_si_function("SHARP-COMMA-READER-FOR-COMPILER",
  2571.              siLsharp_comma_reader_for_compiler);
  2572.  
  2573.     make_si_function("STRING-TO-OBJECT", siLstring_to_object);
  2574.  
  2575.     make_si_function("STANDARD-READTABLE", siLstandard_readtable);
  2576. }
  2577.  
  2578. object siSPinit;
  2579.  
  2580. object
  2581. read_fasl_vector1(in)
  2582. object in;
  2583. {
  2584.     int dimcount, dim;
  2585.     object *vsp;        
  2586.  
  2587.     VOL object x;
  2588.     int i;
  2589.     bool e;
  2590.     object old_READtable;
  2591.     int old_READdefault_float_format;
  2592.     int old_READbase;
  2593.     int old_READsuppress;
  2594.     int old_sharp_eq_context_max;
  2595.     struct sharp_eq_context_struct
  2596.         old_sharp_eq_context[SHARP_EQ_CONTEXT_SIZE];
  2597.     int old_backq_level;
  2598.  
  2599.     old_READtable = READtable;
  2600.     old_READdefault_float_format = READdefault_float_format;
  2601.     old_READbase = READbase;
  2602.     old_READsuppress = READsuppress;
  2603.     old_sharp_eq_context_max = sharp_eq_context_max;
  2604.     /* BUG FIX by Toshiba */
  2605.     vs_push(old_READtable);
  2606.     for (i = 0;  i < sharp_eq_context_max;  i++)
  2607.         old_sharp_eq_context[i] = sharp_eq_context[i];
  2608.     old_backq_level = backq_level;
  2609.  
  2610.     setup_standard_READ();
  2611.  
  2612.     frs_push(FRS_PROTECT, Cnil);
  2613.     if (nlj_active) {
  2614.         e = TRUE;
  2615.         goto L;
  2616.     }
  2617.  
  2618.     while (readc_stream(in) != '#')
  2619.         ;
  2620.     while (readc_stream(in) != '(')
  2621.         ;
  2622.     vsp = vs_top;
  2623.     dimcount = 0;
  2624.     for (;;) {
  2625.         sharp_eq_context_max = 0;
  2626.         backq_level = 0;
  2627.         delimiting_char = code_char(')');
  2628.         preserving_whitespace_flag = FALSE;
  2629.         detect_eos_flag = FALSE;
  2630.         x = read_object(in);
  2631.         if (x == OBJNULL)
  2632.             break;
  2633.         vs_check_push(x);
  2634.         if (sharp_eq_context_max > 0)
  2635.             x = vs_head = patch_sharp(x);
  2636.         dimcount++;
  2637.     }
  2638.     if(dimcount==1 && type_of(vs_head)==t_vector)
  2639.       {/* new style where all read at once */
  2640.         x=vs_head;
  2641.         goto DONE;}
  2642.     /* old style separately sharped, and no %init */
  2643.     x=alloc_simple_vector(dimcount,aet_object);
  2644.     vs_push(x);
  2645.     x->v.v_self
  2646.     = (object *)alloc_relblock(dimcount * sizeof(object));
  2647.     for (dim = 0; dim < dimcount; dim++)
  2648.         {SGC_TOUCH(x);
  2649.          x->cfd.cfd_self[dim] = vsp[dim];}
  2650.     
  2651.          
  2652.       DONE:
  2653.     e = FALSE;
  2654.  
  2655. L:
  2656.     frs_pop();
  2657.  
  2658.     READtable = old_READtable;
  2659.     READdefault_float_format = old_READdefault_float_format;
  2660.     READbase = old_READbase;
  2661.     READsuppress = old_READsuppress;
  2662.     sharp_eq_context_max = old_sharp_eq_context_max;
  2663.     for (i = 0;  i < sharp_eq_context_max;  i++)
  2664.         sharp_eq_context[i] = old_sharp_eq_context[i];
  2665.     backq_level = old_backq_level;
  2666.     if (e) {
  2667.         nlj_active = FALSE;
  2668.         unwind(nlj_fr, nlj_tag);
  2669.     }
  2670.     vs_top = vsp;
  2671.     return(x);
  2672. }
  2673.